home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / NEWSOFT / AUGUST / WORKDISC / !Forthmacs / lib / Xmodem < prev    next >
Text File  |  1996-06-12  |  7KB  |  236 lines
  1. \ Silent version using multitasking
  2. \ Xmodem protocol file transfer.
  3. \ Commands:
  4. \   send filename        \ Sends the file
  5. \   receive filename     \ Receives the file
  6. \ The serial line parameters are established by "init-modem", which
  7. \ you may edit if you need to use different ones.
  8. \ The xmodem protocol requires 8 data bits, so changing that parameter
  9. \ won't work.
  10.  
  11. \ ***** Interface to the serial line: *****
  12. \ init-modem   --
  13. \       Establishes the desired baud rate and # of bits on the serial line
  14. \ m-key?     -- flag
  15. \       Flag is true if a character is available on the serial line
  16. \ m-key      -- char
  17. \       Gets a character from the serial line
  18. \ m-emit        char --
  19. \       Puts the character out on the serial line.
  20.  
  21. only forth also definitions
  22. \needs modem cr .( OS specific modem driver must be loaded first) abort
  23.  
  24. only forth also modem also   modem definitions
  25. decimal
  26.  
  27. variable checksum
  28. variable #errors
  29. variable #naks
  30. variable expected-sector
  31. variable #control-z's
  32. variable sector#
  33. variable sector-ptr
  34. variable timer-init
  35. variable timer
  36. variable xmodem-fd    xmodem-fd off
  37. variable xmodem-#error
  38. variable xread/write    \ 0 receive -- 1 sending
  39.  
  40. string-array xmodem-errors
  41.   ( 0 )  ," receive, read sector"
  42.   ( 1 )  ," sending, write sektor"
  43.   ( 2 )  ," receive, header"
  44.   ( 3 )  ," receive, block"
  45.   ( 4 )  ," receive, checksum"
  46.   ( 5 )  ," receive, canceled"
  47.   ( 6 )  ," receive, timeout"
  48.   ( 7 )  ," receive, bogus char"
  49.   ( 8 )  ," sending, timeout"
  50.   ( 9 )  ," sending, canceled"
  51.   ( 10)  ," sending, received bogus char"
  52.   ( 11)  ," receive, Xmodem started"
  53.   ( 12)  ," sending, Xmodem started"
  54.   ( 13)  ," Xmodem finished"
  55. end-string-array
  56.  
  57.   2 constant xmodem#channel
  58.   4 constant max#errors
  59.   0 constant nul
  60.   1 constant soh
  61.   4 constant eot
  62.   6 constant ack
  63.  21 constant nak
  64.  24 constant can
  65. 128 buffer: sector-buf
  66. 128 buffer: xfname
  67.  
  68. : timeout:  \ name  ( seconds -- )
  69.     create ,  does>  @ ( seconds ) ticks/second  *   timer-init ! ;
  70.  3 timeout: short-timeout
  71.  6 timeout: long-timeout
  72. 60 timeout: initial-timeout
  73.  
  74. short-timeout
  75. : xerr        ( #error -- )
  76.     xmodem-#error ! ;
  77. : init-modem    ( -- )    \ initialize modem line
  78.     8-bits 2-stop-bits no-parity 9600-baud rts/cts set-line ;
  79. : close-xfile    ( -- )
  80.     xmodem-fd @  fclose xmodem-fd off
  81.     m-close ;
  82. : abort-end    ( -- )  \ abort and clean up
  83.     close-xfile -1 xmodem-fd ! stop ;
  84. : normal-end ( -- )   \ clean up
  85.     ack m-emit  close-xfile d# 13 xerr stop ;
  86. : ?interrupt    ( -- )  \ aborts if user types control Z
  87.     key? if key control Z = if abort-end then then ;
  88. : timed-in    ( -- char | -1 ) \ get a character unless timeout
  89.     get-ticks  timer-init @  +  timer !
  90.     begin    m-key? if m-key exit then
  91.         timer @ reached?
  92.     until -1 ;
  93. : gobble    ( -- ) \ eat characters until they stop coming
  94.     short-timeout
  95.     begin timed-in -1 = until
  96.     long-timeout ;
  97. : read-sector    ( adr -- end-of-file? )
  98.     dup 128 xmodem-fd @  fgets  tuck +    ( count end-adr )
  99.     \ Pad with control Z's if necessary
  100.     over 128 swap -  control Z fill  0= ;
  101.  
  102. : write-sector  ( adr -- ) \ write out the sector
  103.     \ Dump out any control Z's left over from last time
  104.     #control-z's @ 0 ?do control Z xmodem-fd @ fputc loop
  105.     \ Count the control z's at the end of the buffer
  106.     #control-z's off   dup dup 127 +    ( addr addr end-address )
  107.     do    i c@  control Z <> ?leave
  108.         1 #control-z's +!
  109.     -1 +loop                ( addr )
  110.     128 #control-z's @ -  xmodem-fd @ fputs ;
  111.  
  112. : receive-error    ( #error -- ) \ eat rest of packet and send a nak
  113.     xerr  gobble  1 #naks +!  #naks @ max#errors >
  114.     if  can m-emit  abort-end then
  115.     nak m-emit ;
  116.  
  117. : receive-header ( -- f ) \ true if header error
  118.     timed-in  dup  -1 =  ?exit
  119.     dup sector# !
  120.     timed-in  dup  -1 =  ?exit
  121.     255 xor <> ;
  122. : receive-sector  ( -- f ) \ true if runt sector
  123.     0 xerr
  124.     0 checksum !  false
  125.     sector-buf  128   bounds
  126.     do    timed-in dup -1 =
  127.         if  ( false -1 )  nip  leave then   ( false char )
  128.         dup  i c!   checksum +!
  129.     loop ( runt-sector? ) ;
  130. : receive-checksum  ( -- f ) \ true if checksum error
  131.     timed-in dup -1 <>    ( char true  |  -1 false )
  132.     if    checksum @ 255 and  <>  then ;
  133. : receive-packet  ( -- f ) \ true if end of transfer
  134.     false timed-in
  135.     case    soh of                    endof
  136.         nul of   1-            exit    endof
  137.         can of   5 xerr     abort-end    endof
  138.         eot of   1- normal-end        exit    endof
  139.         -1  of   6 receive-error    exit    endof
  140.                  7 receive-error    exit
  141.     endcase
  142.     receive-header    if 2 receive-error exit then
  143.     receive-sector    if 3 receive-error exit then
  144.     receive-checksum  if 4 receive-error exit then
  145.     sector-buf write-sector  ack m-emit
  146.     1 expected-sector +!  #naks off ;
  147.  
  148. : wait-ack    ( -- ) \ wait for ack or can
  149.     0 #errors !
  150.     begin    #errors @  max#errors >  #naks @  max#errors > or
  151.         if can m-emit abort-end  then
  152.         ?interrupt  timed-in
  153.         case
  154.             -1  of   1 #errors +!  8 xerr    endof
  155.             can of   9 xerr  abort-end    endof
  156.             ack of   #naks off  exit    endof
  157.             nak of   1 #naks +! exit    endof
  158.             d# 10 xerr
  159.         endcase
  160.     again ;
  161. : wait-nak    ( -- ) \ wait for nak
  162.     initial-timeout  timed-in
  163.     case
  164.         -1  of    8 xerr abort-end    endof
  165.         can of    9 xerr abort-end    endof
  166.         nak of    1 #naks +! exit        endof
  167.             d# 10 xerr
  168.     endcase  long-timeout ;
  169. : send-header    ( -- ) \ header is  soh sector#  sector#not
  170.     soh m-emit  sector# @  255 and  dup m-emit  255 xor m-emit ;
  171. : send-sector    ( -- )
  172.     1 xerr  0 checksum !
  173.     sector-buf  128  bounds
  174.     do i c@  dup m-emit checksum +! loop ;
  175. : send-checksum    ( -- )  checksum @  255 and  m-emit  ;
  176.  
  177. : end-send    ( -- )
  178.     close-xfile
  179.     begin    eot m-emit  wait-ack   #naks @ 0=
  180.     until ;
  181. : (x-setup)    ( -- )
  182.         xmodem#channel m-open  init-modem
  183.     multi   #naks off  #control-z's off  sector# off ;
  184. : receive-setup        \ ( -- )
  185.     (x-setup)  1 expected-sector ! ;
  186. : send-setup        \ ( -- )
  187.     (x-setup)  1 sector# ! ;
  188. : xmodem-free?        ( r/w flag )
  189.     xmodem-fd @ 0> if d# -278 throw then xread/write ! ;
  190.  
  191. \ (receive) and (send) are words executed by the Xmodem-server
  192. \ the expect xmodem-fd to be set correct
  193. : (xreceive)    \ ( -- )
  194.     receive-setup    d# 11 xerr
  195.     gobble  nak m-emit
  196.     begin   ?interrupt  receive-packet
  197.     until    d# 13 xerr  stop ;
  198. : (xsend)    \ ( -- )
  199.     send-setup     d# 12 xerr
  200.     gobble    wait-nak  #naks off
  201.     begin    ?interrupt
  202.         #naks @ 0=
  203.         if    sector-buf read-sector
  204.             if end-send d# 13 xerr stop then
  205.         then
  206.         send-header  send-sector  send-checksum  wait-ack
  207.         #naks @ 0=  if  1 sector# +!  then
  208.     again ;
  209.  
  210. task: Xmodem-server
  211. : (receive)    \ ( id -- )
  212.     xmodem-fd !  ['] (xreceive)  Xmodem-server start ;
  213. : (send)    \ ( id -- )
  214.     xmodem-fd !  ['] (xsend) Xmodem-server start ;
  215.  
  216. forth definitions
  217. : .xmodem-info    ( -- )
  218.     ??cr xmodem-fd @ 0 <= if ." No Xmodem transfer" exit then
  219.     ." Xmodem " xread/write @ 0=
  220.     if    ." reading " xfname ".
  221.         cr ." read " expected-sector @    .d ."  sectors"
  222.     else     ." writing " xfname ". 3 spaces
  223.         xmodem-fd @ fsize 127 + 128 /    .d ."  sectors"
  224.         cr ." sent " sector# @        .d ."  sectors"
  225.     then ;
  226. : receive    \ name ( -- )
  227.     0 xmodem-free? blword locals| fname |
  228.     fname make 0= if d# -273 throw then 
  229.     fname modify fopen ?dup 0= if d# -276 throw then
  230.     fname xfname "copy (receive) ;
  231. : send    \ name ( -- )
  232.     1 xmodem-free? blword locals| fname |
  233.     fname read fopen ?dup 0= if d# -275 throw then
  234.     fname xfname "copy (send) ;
  235. only forth also definitions
  236.